PC Plus SuperCD (UK) 1997 February

home *** CD-ROM | disk | FTP | other *** search

/ PC Plus SuperCD (UK) 1997 February / PC Plus Super CD (Issue 124) (PCP124-2-97) (February 1997).iso / handson / wilf / khamesh.bas < prev next >

Wrap

BASIC Source File | 1997-01-31 | 88.3 KB | 3,785 lines

'<-> DEFINT A-Z DECLARE SUB ziDragging () ' Return if mouse active and still dragging, or else exhausted DECLARE SUB ziDrawBank (FromButton, ToButton) ' Draw a bank of buttons (using Bank array) DECLARE SUB ziExhaust () ' Return when no keystrokes and no mouse buttons DECLARE SUB ziLoadFont (Font$) ' Load a specified font DECLARE SUB ziLocateMCursor (XCoord, YCoord) ' Locate mouse cursor to a named point DECLARE SUB ziMouseOnButton (FromButton, ToButton) ' Sets FoundButton DECLARE SUB ziPublish (Printstring$, size, italic) ' Print a string at graphics cursor (advanced) ' Size = magnitude (per 8 pixels) ' Italic = +1 to make italic ' = +2 to make overprint (no background) DECLARE SUB ziPublishHere (row, col, Printstring$, size, italic) ' Print a string at the specified text position DECLARE SUB ziRadio (Button, FromButton, ToButton) ' Set one button in a Bank, resetting the rest DECLARE SUB ziReadField (Min, Max, Permitted$) ' Read a field at the current TCursor location ' Permitted$ contains: ' * - any characters ' . - allow one full-stop (as decimal) ' A - auto-enter (when filled) ' C - capitalise letters ' E - ESC allowed to finish (skip) field ' J - justify (especially for numeric) ' N - numerics ' P - password-type display ' S - space ' X - alphabetic ' Y - Y or N (upper or lower) DECLARE SUB ziSetMCursorVis (Status) ' Set visibility of mouse cursor ' Status = 0 for OFF ' 1 for ON ' 2 for ENQUIRE (set MCursorVis) ' 10 for TEMPORARILY OFF ' 11 for RESTORED (set MCursorVis) DECLARE SUB ziWander (Timeout!) ' Timeout = in seconds (0 = none) ' Response = 0 = (0:00) timed out ' n = (0:n) displacement into Allowed$ ' key &h01xx &h02xx &h04xx &h08xx &h10xx &h20xx &h40xx ' plain CTRL shift Mouse Fn CTRL-Fn shift-Fn ' Enter 0 * * - double - - - ' (left) 1 * * - left F1 ^F1 +F1 ' (right) 2 * * - right F2 ^F2 +F2 ' (up) 3 * - - both F3 ^F3 +F3 ' (down) 4 * - - leftdrag F4 ^F4 +F4 ' Backspace 5 * * - rightdrag F5 ^F5 +F5 ' Home 6 * * - bothdrag F6 ^F6 +F6 ' End 7 * * - - F7 ^F7 +F7 ' PgUP 8 * * - - F8 ^F8 +F8 ' PgDN 9 * * - - F9 ^F9 +F9 ' Tab 10 * - * - F10 ^F10 +F10 ' Escape 11 * - - - F11 ^F11 +F11 ' 12 - - - - F12 ^F12 +F12 ' Allowed$ = other allowed strokes ' (Note: DClick is a flag permitting Double-clicks of mouse - slower!) DEFINT A-Z DECLARE SUB zsAlignGCursor () ' Align graphic cursor to same as text cursor ' - sets Row, Col, GXloc, GYloc DECLARE SUB zsAlignTCursor () ' Align text cursor to same as graphic cursor ' - sets Row, Col, GXloc, GYloc DECLARE SUB zsLocateGCursor (XCoord, YCoord) ' Locate graphic cursor to a named point DECLARE SUB zsPastel (XCoord, YCoord, Wide, Deep, colour1, colour2) ' Colour the defined oblong with a pastel mix of two colours ' Deep = 0 or 1 - square ' = n - Y-pixel depth DECLARE SUB zsSetScrnMode (Mode, HiRows, HiCols) ' Mode = 9 or 12 ' HiRows = 1 to make high number of rows ' HiCols = 1 to make high number of cols (80) ' Set SCREEN parameters and blank the screen ' - sets ScrnMode, Xmax, Ymax, Rows, Cols, XYRatio! ' - uses FG and optionally BG (colours) DECLARE SUB zsSubstitute (XCoord, YCoord, Wide, Deep, colour1, colour2) ' Substitute one colour with another within the defined oblong ' Deep = 0 or 1 - square ' = n - Y-pixel depth DECLARE SUB zzAlphaSort (Table$()) ' Sort alphabetically the strings in the table; limited by " SortCount" DECLARE SUB zzBasicInt (IntType) ' Execute interrupt (params in REGS.AX etc) DECLARE SUB zzChangeDir (Directory$) ' Change to a particular directory ' -sets Directory$; eg "." will be changed to current directory ' if error occurs, Directory$ is returned as "?" DECLARE SUB zzChangeDrive (Drive$) ' Change to a particular drive ' if Drive$ is empty on input, current drive is returned ' if error occurs, Drive$ is returned as "?" DECLARE SUB zzCritOff () ' turns off Critical Error Handling DECLARE SUB zzCritOn () ' restores normal Critical Error Handling DECLARE SUB zzFileSelectBox (Pattern$) ' File Select Box function to choose an input file DECLARE SUB zzInPath (Field$) ' Return full path to a file (in same string) DECLARE SUB zzSearchD (Pattern$) ' Search for DIRECTORIES matching the pattern ' - sets Directories and Directories$() DECLARE SUB zzSearchF (Pattern$) ' Search for FIILENAMES matching the pattern ' - sets FileNames and FileNames$() DECLARE SUB zzValidate (Directory$) ' validate the named path and return its full ' (unqualified) name, including drive ' if error occcurs, Directory$ is returned as "?" '================================================ '/ UK copyright (c) 1997 by Future Publishing '/ '/ '/ '/ '================================================ TYPE REGISTERS AX AS INTEGER BX AS INTEGER CX AS INTEGER DX AS INTEGER DS AS INTEGER SI AS INTEGER ES AS INTEGER DI AS INTEGER FL AS INTEGER END TYPE TYPE Buttons Xloc AS INTEGER Yloc AS INTEGER Wide AS INTEGER Deep AS INTEGER ' 0 = checkbutton ' 1 = square sculptured ' n = Y-pixels deep State AS INTEGER ' 0 = off ' 1 = on Active AS INTEGER ' 0 = inactive ' 1 = active END TYPE CONST Pi! = 3.14159 CONST Ex! = 2.71828 CONST DegToRad! = .0174533 CONST RadToDeg! = 57.2958 CONST ziNoShift = &H1 CONST ziCTRL = &H2 CONST ziShift = &H4 CONST ziMouse = &H8 CONST ziFn = &H10 CONST ziCTRLFn = &H20 CONST ziShiftFn = &H40 CONST ziL = 1 CONST ziR = 2 CONST ziUp = 3 CONST ziDn = 4 CONST ziBS = 5 CONST ziHome = 6 CONST ziEnd = 7 CONST ziPgUp = 8 CONST ziPgDn = 9 CONST ziTab = 10 CONST ziEsc = 11 CONST ziDbl = 0 CONST ziBoth = 3 CONST ziLDrag = 4 CONST ziRDrag = 5 CONST ziBothDrag = 6 DIM SHARED Regs AS REGISTERS DIM SHARED Bank(20) AS Buttons DIM SHARED Bad, Module$ DIM SHARED Mouse, MCursorVis, MXloc, MYloc DIM SHARED DClick DIM SHARED ScrnMode, bg, fg, TCursor DIM SHARED Xmax, Ymax, GXloc, GYloc, XYratio! DIM SHARED Rows, Cols, row, col DIM SHARED Allowed$, Field$ DIM SHARED FoundButton DIM SHARED Font(255, 7) DIM SHARED Response, HResponse, LResponse DIM SHARED SortCount REDIM SHARED Directories$(500) REDIM SHARED FileNames$(500) DIM SHARED Directories, FileNames DIM SHARED IRET AS STRING * 3 IRET = CHR$(&HB0) + CHR$(&H0) + CHR$(&HCF) DIM SHARED CritSeg, CritPtr, CritCount '++++++++++++++++++++++++ RANDOMIZE TIMER ON ERROR GOTO RESUMENEXT RESUMENEXT: IF ERR = 255 THEN CLS BEEP PRINT "Cannot find module "; Module$ SLEEP SYSTEM END IF IF ERR THEN Bad = ERR RESUME NEXT END IF Regs.AX = &H3524 CALL zzBasicInt(&H21) CritSeg = Regs.ES CritPtr = Regs.BX '++++++++++++++++++++++++ ' Test for presence of a mouse Mouse = 0 Regs.AX = 0 CALL zzBasicInt(&H33) IF Regs.AX THEN Mouse = 1 CALL ziSetMCursorVis(0) END IF '++++++++++++++++++++++++ ' Load the ASCII font CALL ziLoadFont("Ascii8x8") '/==================================/' '/ End of Standard Piecrust code /' '/==================================/' '<+> ' ╔═════════════════════════════════════════════════════════════╗ ' ║ ║ ' ║ Thanks to Ian Sharpe and Paul Grosse for suggestions ║ ' ║ and corrections ║ ' ║ ║ ' ╚═════════════════════════════════════════════════════════════╝ ' ' ' ╔═════════════════════════════════════════════════════════════╗ ' ║ ║ ' ║ Variables, constants and types ║ ' ║ ║ ' ╚═════════════════════════════════════════════════════════════╝ DIM Alpha(26) 'for display of macros (relates to KHAMESH.MAC) DIM Points(7, 20, 2) 'all points of the nest of pentagons DIM Hue(6) 'colour table for beads Hue(0) = 0 '(unused) Hue(1) = 2 'green Hue(2) = 14 'yellow Hue(3) = 65 'orange Hue(4) = 40 'red Hue(5) = 32 'blue Hue(6) = 0 'black DIM Beads(8, 5) 'current status of beads (by position) 'note: only pentagons 2-7 used! DIM Moves(999) 'history of last 1000 moves (0 is used) Automatic = 0 Animated = 1 ScrambleDefault = 20 TYPE MacroRec 'format of records in KHAMESH.MAC MacroLetter AS STRING * 1 MacroName AS STRING * 40 MacroMoves AS STRING * 99 END TYPE DIM FullRecord AS MacroRec ' ╔═════════════════════════════════════════════════════════════╗ ' ║ ║ ' ║ Find - or create - the KHAMESH.MAC file (one time only) ║ ' ║ ║ ' ╚═════════════════════════════════════════════════════════════╝ x$ = "KHAMESH.MAC" CALL zzInPath(x$) IF x$ = "" THEN x$ = ".\KHAMESH.MAC" OPEN x$ FOR RANDOM AS #1 LEN = 140 FullRecord.MacroLetter = " " FullRecord.MacroName = " " FullRecord.MacroMoves = " " FOR i = 1 TO 26 PUT #1, i, FullRecord 'blank all records at first NEXT ' set up as 'unusable' all those records that correspond to functions functions$ = "AIOQRSU" i = 1 DO j = ASC(MID$(functions$, i, 1)) - 64 FullRecord.MacroLetter = CHR$(96 + j) PUT #1, j, FullRecord i = i + 1 LOOP UNTIL i > LEN(functions$) ELSE OPEN x$ FOR RANDOM AS #1 LEN = 140 END IF ' publish what macros there are (by looking at the MacroLetter of each ' record in KHAMESH.MAC) GOSUB WhatMacros ' ╔═════════════════════════════════════════════════════════════╗ ' ║ ║ ' ║ Make calculations for setting up the screen initially ║ ' ║ ║ ' ╚═════════════════════════════════════════════════════════════╝ fg = 7: bg = 0 CALL zsSetScrnMode(13, 0, 0) ' POINT DETERMINATION: need only be done once! ' main points identify the five corners of each pentagon ' secondary points are halfway between these ' tertiary points are halfway again (between main and secondary points) ' secondary and tertiary points are used for placing beads during animation DRAW "C0" ' determine the main points (seven shells of five points) FOR i = 1 TO 7 FOR j = 4 TO 20 STEP 4 CALL zsLocateGCursor(Xmax \ 2 + 35, Ymax \ 2 + 10) DRAW "C0TA" + LTRIM$(STR$(18 * j - 54)) + "BR" + LTRIM$(STR$(18 * i - 5)) FOR k = 1 TO 2 Points(i, j, k) = POINT(k - 1) NEXT NEXT NEXT ' determine the secondary points (five shells of five mid-points) FOR i = 2 TO 6 FOR j = 4 TO 20 STEP 4 k = ((j \ 4) MOD 5) * 4 + 4 FOR m = 1 TO 2 Points(i, k - 2, m) = (Points(i, j, m) + Points(i, k, m)) \ 2 NEXT NEXT NEXT ' determine the tertiary points (five shells of another ten mid-points) FOR i = 2 TO 6 FOR j = 2 TO 20 STEP 2 k = ((j \ 2) MOD 10) * 2 + 2 FOR m = 1 TO 2 Points(i, k - 1, m) = (Points(i, j, m) + Points(i, k, m)) \ 2 NEXT NEXT NEXT fg = 7: bg = 66 CALL zsSetScrnMode(13, 0, 0) GOSUB RestoreBlock ' colour all the regular beads GOSUB ColourBeads ' ╔═════════════════════════════════════════════════════════════╗ ' ║ ║ ' ║ Handle keystrokes ║ ' ║ ║ ' ╚═════════════════════════════════════════════════════════════╝ fg = 0 ' Here is the place we spend most of the time in the program: servicing ' keystrokes. ' A,a - changes animation switch (initially ON) ' Q,esc - permits 'QUIT' sequence ' R,r - restart (all beads in correct place) ' S,s - scramble (random moves) ' U,u - undo last move (if still in history record) ' F1 - start a macro (or stop a macro) ' F2 - show a macro ' ' also there are standard moves: ' ' O - rotate outer ring clockwise ' o - rotate outer ring anticlockwise ' I - rotate inner ring clockwise ' i - rotate inner ring anticlockwise ' UParrow - shuttle the columns inward ' DNarrow - shuttle the columns outward ' * - shuttle the columns in the opposite direction DO ' Beep whenever the user has got the beads in the correct places ' (black beads can be anywhere) IF Count <> 0 AND OldCount <> Count THEN Ordered = -1 FOR j = 4 TO 20 STEP 4 OrderedHue = Hue(j \ 4) FOR k = 3 TO 6 IF OrderedHue <> Hue(Beads(k, j \ 4)) THEN Ordered = 0 END IF NEXT NEXT IF Ordered THEN BEEP: BEEP END IF END IF OldCount = Count GOSUB GetAKeystroke Symbol$ = RIGHT$(key$, 1) SELECT CASE LEN(key$) CASE 1 SELECT CASE UCASE$(key$) CASE "A" 'change Animation Animated = 1 - Animated IF Animated = 0 THEN x$ = " " ELSE x$ = CHR$(251) END IF fg = 1: CALL ziPublishHere(2, 30, x$, 0, 1) CASE "Q", CHR$(27) 'quit fg = 0: bg = 48 x = Xmax \ 6: y = Ymax \ 4 LINE (x + x, y)-(4 * x, y + y), bg, BF 'give option to quit LINE (x + x, y)-(4 * x, y + y), 0, B CALL ziPublishHere(8, 16, "Quit?", 2, 0) CALL ziPublishHere(11, 18, "(Y/N)", 1, 0) DO GOSUB GetAKeystroke key$ = UCASE$(key$) x = INSTR(CHR$(27) + "QqNnYy", key$) LOOP UNTIL x > 0 IF x > 5 THEN LINE (0, 0)-(Xmax, Ymax), 66, BF SYSTEM END IF GOSUB RestoreBlock 'go back to normal running CASE "R" 'restart Recording = 0 'turn off any macro being recorded GOSUB RecordingBlock GOSUB WhatMacros GOSUB ResetCount 'reset the count and bead locations GOSUB ColourBeads CASE "S" 'scramble fg = 0: bg = 48 x = Xmax \ 12: y = Ymax \ 8 LINE (x, y + y)-(12 * x, 5 * y), bg, BF LINE (x, y + y)-(12 * x, 5 * y), 0, B Shuffstr$ = RIGHT$(STR$(ScrambleDefault + 100), 2) Shuff = VAL(Shuffstr$) CALL ziPublishHere(8, 18, "Scramble", 1, 0) fg = 4: CALL ziPublishHere(10, 8, "How Many Moves?", 2, 0) fg = 0: CALL ziPublishHere(13, 19, Shuffstr$, 3, 0) fg = 4: CALL ziPublishHere(14, 5, "PgUP/PgDN", 0, 0) CALL ziPublishHere(14, 32, CHR$(24) + " / " + CHR$(25), 0, 0) fg = 0: CALL ziPublishHere(15, 8, CHR$(241) + "10", 0, 0) CALL ziPublishHere(15, 33, CHR$(241) + "1", 0, 0) DO GOSUB GetAKeystroke key$ = UCASE$(key$) SELECT CASE LEN(key$) CASE 1 SELECT CASE ASC(key$) CASE 13 'Enter ScrambleDefault = VAL(Shuffstr$) Shuff = ScrambleDefault EXIT DO CASE 27 'Escape Shuff = 0 EXIT DO END SELECT CASE 2 SELECT CASE ASC(RIGHT$(key$, 1)) CASE 72 'Up x = 1 CASE 73 'Page Up x = 10 CASE 80 'Down IF Shuff = 1 THEN x = 98 ELSE x = 99 END IF CASE 81 'Page Down x = 90 CASE ELSE x = 0 END SELECT IF x <> 0 THEN Shuff = (Shuff + x) MOD 100 IF Shuff = 0 THEN Shuff = 1 END IF Shuffstr$ = RIGHT$(STR$(Shuff + 100), 2) CALL ziPublishHere(13, 19, Shuffstr$, 3, 0) END IF END SELECT LOOP GOSUB RestoreBlock IF Shuff THEN Recording = 0 bg = 66 GOSUB RecordingBlock GOSUB WhatMacros GOSUB ResetCount Automatic = 1 FOR RndCount = 1 TO Shuff x = INT(RND * 3) IF x = 0 THEN GOSUB UpDownArrow ELSE Outer = x - 1 Clockwise = Outer GOSUB MoveBeads END IF NEXT Automatic = 0 GOSUB ReColourBeads END IF CASE "U" 'undo Recording = 0 'turn off any macro being recorded GOSUB RecordingBlock GOSUB WhatMacros IF Count <> 0 THEN i = Count MOD 1000 'delve into the history to get last move key$ = CHR$(Moves(i)) IF ASC(key$) <> 0 THEN Moves(i) = 0 'if move is available, run it "backward" Count = Count - 2 GOSUB BackwardMove END IF END IF CASE "O", "I", "*" 'NORMAL moves GOSUB ForwardMove 'perform a normal move GOSUB RecordMove 'record it if a macro is on CASE ELSE 'macros IF INSTR(Macros$, UCASE$(key$)) THEN Recording = 0 'no macros within macros, so turn off! GOSUB RecordingBlock GOSUB WhatMacros GOSUB MacroBody 'perform the macro END IF END SELECT CASE 2 SELECT CASE MID$(key$, 2) 'for 'long' responses, select second byte CASE "H", "P" 'up arrow, down arrow key$ = "*" Symbol$ = "*" GOSUB ForwardMove 'perform the move GOSUB RecordMove 'record it if a macro is on CASE CHR$(59) 'F1 key IF Recording = 0 THEN 'START a macro GOSUB WhichMacro 'ask "Which Macro?" fg = 0: CALL ziPublishHere(8, 16, "Start Macro", 1, 0) DO GOSUB GetAKeystroke Chosen$ = UCASE$(key$) 'here is the chosen macro letter x = INSTR(Macros$ + Available$ + CHR$(27), Chosen$) LOOP UNTIL x > 0 'check that this letter is allowable IF ASC(Chosen$) <> 27 THEN 'if not escape, continue IF INSTR(Macros$, Chosen$) > 0 THEN bg = 48 'this macro exists! x = Xmax \ 6: y = Ymax \ 4 LINE (x, y)-(5 * x, y + y), bg, BF LINE (x, y)-(5 * x, y + y), 0, B CALL ziPublishHere(8, 9, "Overwrite " + Chosen$ + "?", 2, 0) CALL ziPublishHere(11, 18, "(Y/N)", 1, 0) DO GOSUB GetAKeystroke key$ = UCASE$(key$) x = INSTR(CHR$(27) + "QqNnYy", key$) LOOP UNTIL x > 0 IF x > 5 THEN ' now we must expunge the record of any EARLIER use of this macro ' (to prevent "Undoing" the old contents) x = Count MOD 1000 FOR i = 0 TO x IF UCASE$(CHR$(Moves(i))) = Chosen$ THEN FOR j = i TO 0 STEP -1 Moves(j) = 0 NEXT FOR j = 999 TO x STEP -1 IF j <> x THEN Moves(j) = 0 END IF NEXT END IF NEXT ' rewrite the MAC record to indicate that this macro is now empty GOSUB EmptyMacro ELSE Chosen$ = CHR$(27) END IF ELSE ' make sure this macro is now empty GOSUB EmptyMacro END IF END IF IF Chosen$ <> CHR$(27) THEN Recording = 1 'from now on, we are recording! GOSUB RecordingBlock ELSE GOSUB RestoreBlock END IF ELSE 'STOP MACRO is chosen Recording = 0 'simply reset the Recording flag.. GOSUB RecordingBlock '..and turn off the block GOSUB WhatMacros 're-establish the macro list END IF CASE CHR$(60) 'F2 key: DISPLAY MACRO GOSUB WhichMacro fg = 0: CALL ziPublishHere(8, 16, "Show Macro", 1, 0) DO 'find out which macro to display GOSUB GetAKeystroke key$ = UCASE$(key$) x = INSTR(Macros$ + CHR$(27), key$) LOOP UNTIL x > 0 IF ASC(key$) <> 27 THEN bg = 48: GOSUB StartScreen 'change the screen fg = 0: CALL ziPublishHere(2, 20, "Macro ", 2, 0) CALL ziPublish(key$, 2, 0) RecordNumber = ASC(UCASE$(key$)) - 64 GET #1, RecordNumber, FullRecord ' display the actual macro fg = 7 FOR i = 1 TO 99 row = (i - 1) MOD 20 + 6 col = ((i - 1) \ 20) * 8 + 2 x$ = RIGHT$(STR$(100 + i), 2) y$ = MID$(FullRecord.MacroMoves, i, 1) IF y$ = " " THEN fg = 7 ELSE fg = 0 END IF CALL ziPublishHere(row, col, x$, 1, 0) fg = 4: CALL ziPublish(" " + y$, 1, 0) NEXT ' show the name (and allow editing) disp = 1: newdisp = 1 fg = 8: CALL ziPublishHere(4, 1, FullRecord.MacroName, 1, 2) DO CALL ziPublishHere(5, disp, "^", 1, 0) GOSUB GetAKeystroke IF LEN(key$) = 1 THEN SELECT CASE key$ CASE CHR$(8) 'backspace MID$(FullRecord.MacroName, disp, 1) = " " fg = 8: CALL ziPublishHere(4, disp, " ", 1, 0) newdisp = (disp + 38) MOD 40 + 1 CASE CHR$(13) 'return PUT #1, RecordNumber, FullRecord EXIT DO CASE CHR$(27) 'escape EXIT DO CASE " " TO "z" IF LEN(key$) = 1 THEN MID$(FullRecord.MacroName, disp, 1) = key$ fg = 8: CALL ziPublishHere(4, disp, key$, 1, 0) END IF newdisp = disp MOD 40 + 1 END SELECT ELSE x = ASC(RIGHT$(key$, 1)) SELECT CASE x CASE 71 'home newdisp = 1 CASE 79 'end newdisp = 41 DO newdisp = newdisp - 1 IF MID$(FullRecord.MacroName, newdisp, 1) <> " " THEN EXIT DO END IF IF newdisp = 1 THEN newdisp = 0 EXIT DO END IF LOOP IF newdisp < 40 THEN newdisp = newdisp + 1 END IF CASE 75 'left arrow newdisp = (disp + 38) MOD 40 + 1 CASE 77 'right arrow newdisp = disp MOD 40 + 1 CASE 82 'insert newdisp = disp IF disp < 40 THEN FOR i = 39 TO disp STEP -1 x$ = MID$(FullRecord.MacroName, i, 1) MID$(FullRecord.MacroName, i + 1, 1) = x$ NEXT END IF MID$(FullRecord.MacroName, disp, 1) = " " CALL ziPublishHere(4, 1, FullRecord.MacroName, 1, 0) CASE 83 'delete newdisp = disp IF disp < 40 THEN FOR i = disp TO 39 x$ = MID$(FullRecord.MacroName, i + 1, 1) MID$(FullRecord.MacroName, i, 1) = x$ NEXT END IF MID$(FullRecord.MacroName, 40, 1) = " " CALL ziPublishHere(4, 1, FullRecord.MacroName, 1, 0) END SELECT END IF CALL ziPublishHere(5, disp, " ", 1, 0) disp = newdisp LOOP END IF ' return to working screen GOSUB RestoreBlock END SELECT END SELECT LOOP ' ' ╔═════════════════════════════════════════════════════════════╗ ' ║ ║ ' ║ ╔══ ╦ ╦ ╦═╗ ╦═╗ ╔═╗ ╦ ╦ ═╦═ ╦ ╦═╗ ╔══ ╔══ ║ ' ║ ╚═╗ ║ ║ ╠═╣ ╠╦╝ ║ ║ ║ ║ ║ ║ ║ ║ ╠═ ╚═╗ ║ ' ║ ══╝ ╚═╝ ╩═╝ ╝╚═ ╚═╝ ╚═╝ ╩ ╩ ╩ ╩ ╚══ ══╝ ║ ' ║ ║ ' ╚═════════════════════════════════════════════════════════════╝ ' ╔════════════╗ ' ║ AddToCount ╟─────────────────────────────────────────────────┐ ' ╚╤═══════════╝ │ ' │ Add one to the counter displayed on the screen and │ ' │ tidy the history │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ AddToCount: IF Expanding = 0 THEN Count = Count + 1 x$ = RIGHT$("00000" + MID$(STR$(Count), 2), 6) fg = 0: CALL ziPublishHere(5, 34, x$, 0, 0) i = Count MOD 1000 IF Moves(i) = 0 THEN Moves(i) = ASC(Symbol$) END IF i = (i + 1) MOD 1000 Moves(i) = 0 END IF RETURN ' ' ╔════════════╗ ' ║ Alphabet ╟─────────────────────────────────────────────────┐ ' ╚╤═══════════╝ │ ' │ Go through the alphabet and publish what are MACROS │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ Alphabet: fg = 7: bg = 15 CALL ziPublishHere(18, 3, " ABCDEFGH ", 0, 0) CALL ziPublishHere(19, 3, "IJKLMNOPQ ", 0, 0) CALL ziPublishHere(20, 3, "RSTUVWXYZ ", 0, 0) fg = 0: bg = 66 CALL ziPublishHere(17, 5, "macros", 0, 1) Macros$ = "" Available$ = "" FOR i = 1 TO 26 j = 18 + i \ 9 k = i MOD 9 + 3 SELECT CASE Alpha(i) CASE 0 Available$ = Available$ + CHR$(64 + i) CASE 1 fg = 4: CALL ziPublishHere(j, k, CHR$(64 + i), 0, 2) Macros$ = Macros$ + CHR$(64 + i) CASE 2 fg = 7: bg = 15: CALL ziPublishHere(j, k, CHR$(249), 0, 0) END SELECT NEXT fg = 0: bg = 66 RETURN ' ' ╔═══════════════════╗ ' ║ BackwardMove ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Make a "backward" move │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ BackwardMove: x = INSTR("IiOo*", key$) IF x > 0 THEN key$ = MID$("iIoO*", x, 1) GOSUB ForwardMove ELSE IF INSTR(Macros$, UCASE$(key$)) THEN key$ = CHR$(ASC(key$) XOR 32) 'swap direction of macro GOSUB MacroBody END IF END IF RETURN ' ' ╔═══════════════════╗ ' ║ ColourBeads ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Colour the beads as at the start of the puzzle │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ ColourBeads: FOR i = 3 TO 6 FOR j = 4 TO 20 STEP 4 Beads(i, j \ 4) = j \ 4 NEXT NEXT FOR i = 1 TO 5 Beads(7, i) = 0 NEXT FOR i = 5 TO 11 STEP 3 Beads(2, i \ 2) = 6 NEXT GOSUB ReColourBeads RETURN ' ' ╔═══════════════════╗ ' ║ EmptyMacro ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Empty the chosen macro, resetting it to available │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ EmptyMacro: x = ASC(Chosen$) - 64 Alpha(x) = 0 FullRecord.MacroLetter = " " FullRecord.MacroName = " " FullRecord.MacroMoves = " " PUT #1, x, FullRecord GOSUB RestoreBlock RETURN ' ' ╔═══════════════════╗ ' ║ ForwardMove ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Move rings or shuttle the columns │ ' │ (I, i, O, o, UParrow, DNarrow) │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ ForwardMove: SELECT CASE UCASE$(key$) CASE "I", "O" 'move a ring Outer = INSTR("O", UCASE$(key$)) IF key$ = UCASE$(key$) THEN Clockwise = 1 ELSE Clockwise = 0 END IF GOSUB AddToCount GOSUB MoveBeads CASE "*" 'arrow move GOSUB UpDownArrow GOSUB AddToCount END SELECT RETURN ' ' ╔═══════════════════╗ ' ║ GetAKeystroke ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Obtain a buffered keystroke in "key$" │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ GetAKeystroke: key$ = "X" DO UNTIL LEN(key$) = 0 key$ = INKEY$ LOOP DO WHILE LEN(key$) = 0 key$ = INKEY$ LOOP RETURN ' ' ╔═══════════════════╗ ' ║ MacroBody ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Expand the body of a macro and execute its parts │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ MacroBody: OSymbol$ = Symbol$ LINE (1, 102)-(87, 128), 1, BF fg = 15: CALL ziPublishHere(14, 3, "Playing", 0, 2) CALL ziPublishHere(15, 5, key$, 2, 2) Expanding = 1 i = ASC(UCASE$(key$)) - 64 GET #1, i, FullRecord IF key$ = UCASE$(key$) THEN FOR MacroPoint = 1 TO 99 key$ = MID$(FullRecord.MacroMoves, MacroPoint, 1) IF key$ = " " THEN EXIT FOR GOSUB ForwardMove NEXT ELSE FOR MacroPoint = 99 TO 1 STEP -1 key$ = MID$(FullRecord.MacroMoves, MacroPoint, 1) IF key$ <> " " THEN GOSUB BackwardMove END IF NEXT END IF Expanding = 0 Symbol$ = OSymbol$ GOSUB AddToCount LINE (1, 102)-(87, 128), bg, BF RETURN ' ' ╔═══════════════════╗ ' ║ MoveBeads ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Establish the "before" and "after" configurations │ ' │ of the beads, then call for animation │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ MoveBeads: x = Outer + Outer y = 5 - 4 * Clockwise i = Beads(x + 3, y) j = Beads(x + 4, y) FOR k = 1 TO 4 FOR m = 3 TO 4 IF Clockwise = 0 THEN Beads(m + x, 6 - k) = Beads(m + x, 5 - k) ELSE Beads(m + x, k) = Beads(m + x, k + 1) END IF NEXT NEXT Beads(x + 3, 6 - y) = i Beads(x + 4, 6 - y) = j A = 3 + 2 * Outer ' turn off the MAIN beads IF Automatic = 0 THEN IF Animated = 1 THEN FOR j = 4 TO 20 STEP 4 FOR k = A TO A + 1 IF j = 4 OR j = 12 THEN IF Outer = 0 THEN Shade = &H50 ELSE Shade = 15 END IF ELSE Shade = 7 END IF FOR m = 1 TO 2 coord(m) = (Points(k, j, m) + Points(k - 1, j, m)) \ 2 NEXT PAINT (coord(1), coord(2)), Shade, Shade NEXT NEXT ' turn on interim beads FOR i = 3 TO 1 STEP -1 FOR j = 4 TO 20 STEP 4 FOR k = A TO A + 1 IF Outer = 0 THEN Shade = &H50 ELSE Shade = 15 END IF IF Clockwise = 0 THEN m = j - i ELSE m = (j + i) MOD 20 END IF FOR n = 1 TO 2 coord(n) = (Points(k, m, n) + Points(k - 1, m, n)) \ 2 NEXT CIRCLE (coord(1), coord(2)), 2, 8 IF Clockwise = 0 THEN PAINT (coord(1), coord(2)), Hue(Beads(k, (m \ 4 + 5) MOD 5 + 1)), 8 ELSE PAINT (coord(1), coord(2)), Hue(Beads(k, (m \ 4 + 4) MOD 5 + 1)), 8 END IF NEXT NEXT PLAY "MBL64N0N0" DO: LOOP UNTIL PLAY(0) = 0 FOR j = 4 TO 20 STEP 4 FOR k = A TO A + 1 FOR m = 1 TO 2 IF Clockwise = 0 THEN n = j - i ELSE n = (j + i) MOD 20 END IF coord(m) = (Points(k, n, m) + Points(k - 1, n, m)) \ 2 NEXT PAINT (coord(1), coord(2)), Shade, Shade NEXT NEXT NEXT END IF END IF ' turn on final MAIN beads FOR j = 4 TO 20 STEP 4 FOR k = A TO A + 1 FOR m = 1 TO 2 coord(m) = (Points(k, j, m) + Points(k - 1, j, m)) \ 2 NEXT IF Automatic = 0 THEN CIRCLE (coord(1), coord(2)), 2, 8 PAINT (coord(1), coord(2)), Hue(Beads(k, j \ 4)), 8 END IF NEXT NEXT RETURN ' ' ╔═══════════════════╗ ' ║ ReColourBeads ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Restore the colours of the beads to the current state │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ ReColourBeads: FOR i = 3 TO 6 FOR j = 4 TO 20 STEP 4 FOR m = 1 TO 2 coord(m) = (Points(i, j, m) + Points(i - 1, j, m)) \ 2 NEXT CIRCLE (coord(1), coord(2)), 2, 8 PAINT (coord(1), coord(2)), Hue(Beads(i, j \ 4)), 8 NEXT NEXT fg = 0 GOSUB SetArrows RETURN ' ' ╔═══════════════════╗ ' ║ RecordingBlock ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Handle the "Recording" block - whether or not it appears │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ RecordingBlock: IF Recording = 1 THEN LINE (1, 102)-(87, 128), 4, BF LINE (1, 102)-(87, 128), 0, B fg = 15: CALL ziPublishHere(14, 2, "Recording", 0, 2) CALL ziPublishHere(15, 5, Chosen$, 2, 2) fg = 0: CALL ziPublishHere(22, 7, "stop ", 0, 0) ELSE LINE (1, 102)-(87, 128), bg, BF fg = 0: CALL ziPublishHere(22, 7, "start", 0, 0) END IF RETURN ' ' ╔═══════════════════╗ ' ║ RecordMove ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ If recording a macro, record the move just performed │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ RecordMove: IF Recording = 1 THEN FullRecord.MacroLetter = UCASE$(Chosen$) x$ = RTRIM$(FullRecord.MacroMoves) FullRecord.MacroMoves = x$ + key$ PUT #1, ASC(UCASE$(Chosen$)) - 64, FullRecord IF LEN(x$) = 99 THEN Recording = 0 GOSUB RecordingBlock GOSUB WhatMacros END IF END IF RETURN ' ' ╔═══════════════════╗ ' ║ ResetCount ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Rest the count to zero and clear the history │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ ResetCount: FOR i = 0 TO 999 Moves(i) = 0 NEXT Count = 0 fg = 0: CALL ziPublishHere(5, 34, "000000", 0, 0) RETURN ' ' ╔════════════════╗ ' ║ RestoreBlock ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ Restore the block used to run "quit" and "macro" options │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ RestoreBlock: bg = 66 GOSUB StartScreen IF Animated = 0 THEN x$ = " " ELSE x$ = CHR$(251) END IF fg = 1: CALL ziPublishHere(2, 30, x$, 0, 1) fg = 0 GOSUB Alphabet ' colour the end-indicators FOR i = 4 TO 20 STEP 4 CIRCLE (Points(7, i, 1), Points(7, i, 2)), 8, 0 PAINT (Points(7, i, 1), Points(7, i, 2)), Hue(i \ 4), 0 NEXT ' join the points FOR i = 1 TO 7 FOR j = 4 TO 20 STEP 4 k = ((j \ 4) MOD 5) * 4 + 4 LINE (Points(i, j, 1), Points(i, j, 2))-(Points(i, k, 1), Points(i, k, 2)), 8 NEXT NEXT PAINT (Xmax \ 2 + 35, Ymax \ 2 + 10), 3, 8 x$ = CHR$(66) + CHR$(3) + CHR$(&H50) + CHR$(&H50) + CHR$(15) + CHR$(15) + CHR$(3) FOR i = 1 TO 7 j = ASC(MID$(x$, i, 1)) PAINT (Points(i, 8, 1), Points(i, 8, 2) + 10), j, 8 NEXT ' calculate the corridor walls for the "Yellow" column x1 = Points(1, 8, 1) + 5 y1 = Points(1, 8, 2) + 3 x2 = Points(7, 8, 1) + 5 y2 = Points(7, 8, 2) + 3 LINE (x1, y1)-(x2, y2), 8 x1 = Points(1, 8, 1) - 5 x2 = Points(7, 8, 1) - 5 LINE (x1, y1)-(x2, y2), 8 ' draw the outer corridor wall for the "Red" and "Blue" columns x1 = Points(1, 16, 1) - 3 y1 = Points(1, 16, 2) - 6 x2 = Points(7, 16, 1) - 3 y2 = Points(7, 16, 2) - 6 LINE (x1, y1)-(x2, y2), 8 x1 = Points(1, 20, 1) + 2 y1 = Points(1, 20, 2) - 4 x2 = Points(7, 20, 1) + 1 y2 = Points(7, 20, 2) - 6 LINE (x1, y1)-(x2, y2), 8 ' draw the inner corridor wall for the "Red" and "Blue" columns x1 = Points(1, 16, 1) + 7 y1 = Points(1, 16, 2) x2 = Points(7, 16, 1) + 7 y2 = Points(7, 16, 2) LINE (x1, y1)-(x2, y2), 8 x1 = Points(1, 20, 1) - 7 y1 = Points(1, 20, 2) x2 = Points(7, 20, 1) - 7 y2 = Points(7, 20, 2) LINE (x1, y1)-(x2, y2), 8 ' shade all the columns grey FOR i = 5 TO 11 STEP 3 j = (i \ 2) * 4 FOR k = 2 TO 6 FOR m = 1 TO 2 coord(m) = (Points(k, j, m) + Points(k - 1, j, m)) \ 2 NEXT PAINT (coord(1), coord(2)), 7, 8 NEXT NEXT fg = 4: CALL ziPublishHere(4, 2, CHR$(24), 0, 0) fg = 0: CALL ziPublish(" columns in", 0, 0) fg = 4: CALL ziPublishHere(5, 2, CHR$(25), 0, 0) fg = 0: CALL ziPublish(" columns out", 0, 0) fg = 4: CALL ziPublishHere(6, 2, "O", 0, 0) fg = 0: CALL ziPublish(" outer ring", 0, 0) fg = 4: CALL ziPublishHere(7, 2, "I", 0, 0) fg = 0: CALL ziPublish(" inner ring", 0, 0) fg = 4: CALL ziPublishHere(9, 2, "Q", 0, 0) fg = 0: CALL ziPublish("uit", 0, 0) fg = 4: CALL ziPublishHere(10, 2, "R", 0, 0) fg = 0: CALL ziPublish("estart", 0, 0) fg = 4: CALL ziPublishHere(11, 2, "S", 0, 0) fg = 0: CALL ziPublish("cramble", 0, 0) fg = 4: CALL ziPublishHere(12, 2, "U", 0, 0) fg = 0: CALL ziPublish("ndo", 0, 0) fg = 4: CALL ziPublishHere(22, 4, "F1 ", 0, 0) fg = 4: CALL ziPublishHere(23, 4, "F2 ", 0, 0) fg = 0: CALL ziPublish("show", 0, 0) IF Anitmated = 0 THEN x$ = " " ELSE x$ = CHR$(251) END IF fg = 1: CALL ziPublishHere(2, 30, x$ + " ", 0, 1) fg = 4: CALL ziPublish("A", 0, 0) fg = 0: CALL ziPublish("nimate", 0, 0) fg = 8: CALL ziPublishHere(4, 34, "count:", 0, 1) x$ = RIGHT$("00000" + MID$(STR$(Count), 2), 6) fg = 0: CALL ziPublishHere(5, 34, x$, 0, 2) GOSUB RecordingBlock GOSUB ReColourBeads RETURN ' ' ╔════════════════╗ ' ║ SetArrows ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ Set the arrows as required │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ SetArrows: fg = 0 CALL zsLocateGCursor(191, 105) IF Beads(2, 2) = 0 THEN IF Automatic = 0 THEN CALL ziPublish(CHR$(24), 0, 0) END IF FOR i = 5 TO 11 STEP 3 j = (i \ 2) * 4 FOR m = 1 TO 2 coord(m) = (Points(7, j, m) + Points(6, j, m)) \ 2 NEXT IF Automatic = 0 THEN PAINT (coord(1), coord(2)), 7, 8 CIRCLE (coord(1), coord(2)), 2, 8 PAINT (coord(1), coord(2)), Hue(Beads(7, j \ 4)), 8 END IF FOR m = 1 TO 2 coord(m) = (Points(2, j, m) + Points(1, j, m)) \ 2 NEXT IF Automatic = 0 THEN CIRCLE (coord(1), coord(2)), 2, 0 PAINT (Points(2, j, 1), Points(2, j, 2) - 5 * SGN(j - 12)), 66, 8 END IF NEXT ELSE IF Automatic = 0 THEN CALL ziPublish(CHR$(25), 0, 0) END IF FOR i = 5 TO 11 STEP 3 j = (i \ 2) * 4 FOR m = 1 TO 2 coord(m) = (Points(2, j, m) + Points(1, j, m)) \ 2 NEXT IF Automatic = 0 THEN PAINT (coord(1), coord(2)), 7, 8 CIRCLE (coord(1), coord(2)), 2, 8 PAINT (coord(1), coord(2)), Hue(Beads(2, j \ 4)), 8 END IF FOR m = 1 TO 2 coord(m) = (Points(7, j, m) + Points(6, j, m)) \ 2 NEXT IF Automatic = 0 THEN CIRCLE (coord(1), coord(2)), 2, 0 PAINT (Points(7, j, 1), Points(7, j, 2) - 5 * SGN(j - 12)), 66, 8 END IF NEXT END IF RETURN ' ' ╔═════════════════════╗ ' ║ StartScreen ╟────────────────────────────────────────┐ ' ╚╤════════════════════╝ │ ' │ Start the screen - with the KHAMESH logo - based on │ ' │ the colour noted in "bg" │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ StartScreen: fg = 7 LINE (0, 0)-(Xmax, Ymax), bg, BF fg = 4: CALL ziPublishHere(2, 2, "KHAMESH", 2, 0) RETURN ' ' ╔═══════════════════╗ ' ║ UpDownArrow ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Move beads to new configuration when shuttling the │ ' │ columns (with "*", UParrow and DNarrow) │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ UpDownArrow: FOR i = 5 TO 11 STEP 3 j = (i \ 2) * 4 IF Beads(2, 5) = 0 THEN FOR k = 2 TO 7 Beads(k, j \ 4) = Beads(k + 1, j \ 4) FOR m = 1 TO 2 coord(m) = (Points(k, j, m) + Points(k - 1, j, m)) \ 2 NEXT IF Automatic = 0 THEN PAINT (coord(1), coord(2)), Hue(Beads(k, j \ 4)), 8 END IF NEXT ELSE FOR k = 7 TO 2 STEP -1 Beads(k, j \ 4) = Beads(k - 1, j \ 4) FOR m = 1 TO 2 coord(m) = (Points(k, j, m) + Points(k - 1, j, m)) \ 2 NEXT IF Automatic = 0 THEN PAINT (coord(1), coord(2)), Hue(Beads(k, j \ 4)), 8 END IF NEXT END IF NEXT GOSUB SetArrows IF Automatic = 0 THEN IF Animated = 1 THEN PLAY "MBL64N0N0" DO: LOOP UNTIL PLAY(0) = 0 END IF END IF RETURN ' ' ╔═══════════════════╗ ' ║ WhatMacros ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Go through records in KHAMESH.MAC to determine the │ ' │ existing macros │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ WhatMacros: FOR i = 1 TO 26 GET #1, i, FullRecord SELECT CASE ASC(FullRecord.MacroLetter) CASE i + 64 Alpha(i) = 1 'macro CASE i + 96 Alpha(i) = 2 'function END SELECT NEXT GOSUB Alphabet RETURN ' ' ╔═══════════════════╗ ' ║ WhichMacro ╟──────────────────────────────────────────┐ ' ╚╤══════════════════╝ │ ' │ Publish box calling for "Which Macro?" │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ WhichMacro: bg = 48 x = Xmax \ 6: y = Ymax \ 4 LINE (x, y)-(5 * x, y + y), bg, BF LINE (x, y)-(5 * x, y + y), 0, B fg = 4 CALL ziPublishHere(10, 9, "Which Macro?", 2, 0) RETURN '<-> ' '++++++++++++++++++++++++ SUB ziDragging IF Mouse AND MCursorVis THEN SELECT CASE Response CASE 2052 TO 2054 Regs.AX = 3 CALL zzBasicInt(&H33) IF Regs.BX = Response - 2051 THEN EXIT SUB END IF END SELECT END IF CALL ziExhaust END SUB ' '++++++++++++++++++++++++ SUB ziDrawBank (FromButton, ToButton) CALL ziSetMCursorVis(10) FOR i = FromButton TO ToButton IF Bank(i).Active THEN IF Bank(i).State THEN colour1 = 8 ELSE colour1 = 15 END IF colour2 = colour1 XOR 7 XCoord = Bank(i).Xloc YCoord = Bank(i).Yloc XWidth = Bank(i).Wide YDepth = Bank(i).Deep X2Coord = XCoord + XWidth IF YDepth THEN IF YDepth = 1 THEN Y2Coord = YCoord + XWidth / XYratio! ELSE Y2Coord = YCoord + YDepth END IF LINE (XCoord, YCoord)-(X2Coord - 1, YCoord), colour1 LINE (XCoord, YCoord)-(XCoord, Y2Coord - 1), colour1 LINE (XCoord + 1, Y2Coord)-(X2Coord, Y2Coord), colour2 LINE (X2Coord, YCoord)-(X2Coord, Y2Coord), colour2 ELSE A = XWidth \ 2 B = A / XYratio! C = XCoord + A D = YCoord + B LINE (XCoord, YCoord)-(C + A, D + B), 7, BF CIRCLE (C, D), A, 8 CIRCLE (C, D), A - 1, 8 PAINT (C, D), 7, 7 IF Bank(i).State THEN CIRCLE (C, D), XWidth \ 3, 8 PAINT (C, D), 8, 8 END IF END IF END IF NEXT CALL ziSetMCursorVis(11) END SUB ' '++++++++++++++++++++++++ SUB ziExhaust DO x$ = INKEY$ LOOP WHILE LEN(x$) IF Mouse AND MCursorVis THEN DO Regs.AX = 3 CALL zzBasicInt(&H33) LOOP WHILE (Regs.BX AND 3) END IF Response = 0 END SUB ' '++++++++++++++++++++++++ SUB ziLoadFont (Font$) DEF SEG = VARSEG(Font(0, 0)) Module$ = Font$ + ".OVL" CALL zzInPath(Module$) IF Module$ = "" THEN Module$ = Font$ + ".OVL" ERROR 255 ELSE BLOAD Module$, VARPTR(Font(0, 0)) END IF DEF SEG END SUB ' '++++++++++++++++++++++++ SUB ziLocateMCursor (XCoord, YCoord) IF Mouse THEN MXloc = XCoord MYloc = YCoord Regs.AX = 4 Regs.CX = XCoord Regs.DX = YCoord CALL zzBasicInt(&H33) CALL ziSetMCursorVis(1) END IF END SUB ' '++++++++++++++++++++++++ SUB ziMouseOnButton (FromButton, ToButton) FoundButton = 0 FOR i = FromButton TO ToButton IF Bank(i).Active THEN IF Bank(i).Deep < 2 THEN j = Bank(i).Wide / XYratio! ELSE j = Bank(i).Deep END IF IF MXloc > Bank(i).Xloc THEN IF MXloc < Bank(i).Xloc + Bank(i).Wide THEN IF MYloc > Bank(i).Yloc THEN IF MYloc < Bank(i).Yloc + j THEN FoundButton = i EXIT SUB END IF END IF END IF END IF ELSE EXIT SUB END IF NEXT END SUB ' '++++++++++++++++++++++++ SUB ziPublish (Printstring$, size, italic) CALL ziSetMCursorVis(10) xx = POINT(0) yy = POINT(1) IF size THEN Scale = size ELSE Scale = 1 END IF LenString = LEN(Printstring$) ExpScale = 8 * Scale limxx = xx + ExpScale * LenString - 1 limyy = yy + ExpScale - 1 IF italic AND 1 THEN limxx = limxx + 4 * Scale END IF IF italic AND 2 THEN ELSE LINE (xx, yy)-(limxx, limyy), bg, BF END IF FOR A = 0 TO LenString - 1 x = ASC(MID$(Printstring$, A + 1, 1)) B = xx + ExpScale * A FOR y = 0 TO 7 C = Font(x, y) D = y * Scale e = yy + D IF italic AND 1 THEN F = B + 4 * Scale - (D + Scale - 1) \ 2 - 1 ELSE F = B END IF G = 128 DO IF C AND G THEN FOR h = 0 TO Scale - 1 FOR i = 0 TO Scale - 1 PSET (F + h, e + i), fg NEXT NEXT END IF F = F + Scale G = G \ 2 LOOP UNTIL G = 0 NEXT NEXT CALL zsLocateGCursor(limxx + 1, yy) CALL ziSetMCursorVis(11) END SUB SUB ziPublishHere (row, col, Printstring$, size, italic) IF row + col > 0 THEN LOCATE row, col END IF CALL zsAlignGCursor CALL ziPublish(Printstring$, size, italic) CALL zsAlignTCursor END SUB ' '++++++++++++++++++++++++ SUB ziRadio (Button, FromButton, ToButton) IF Button >= FromButton THEN IF Button <= ToButton THEN FOR A = FromButton TO ToButton Bank(A).State = 0 NEXT END IF END IF Bank(Button).State = 1 CALL ziDrawBank(FromButton, ToButton) END SUB ' '++++++++++++++++++++++++ SUB ziReadField (Min, Max, Permitted$) CALL ziSetMCursorVis(10) atRow = CSRLIN atCol = POS(x) Field$ = "" PRINT CHR$(219); SPACE$(Max); Rules$ = UCASE$(Permitted$) brake = 1 WHILE brake x$ = "" WHILE LEN(x$) = 0 x$ = INKEY$ WEND IF INSTR(Rules$, "C") THEN x$ = UCASE$(x$) oldLen = LEN(Field$) Good = 0 IF INSTR(Rules$, ".") THEN IF x$ = "." THEN IF INSTR(Field$, ".") = 0 THEN Good = 1 END IF END IF END IF IF INSTR(Rules$, "N") THEN IF INSTR("0123456789", x$) THEN Good = 1 END IF END IF IF INSTR(Rules$, "S") THEN IF x$ = " " THEN Good = 1 END IF END IF IF INSTR(Rules$, "X") THEN IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ", UCASE$(x$)) THEN Good = 1 END IF END IF IF INSTR(Rules$, "Y") THEN IF INSTR("YyNy", x$) THEN Good = 1 END IF END IF IF Good THEN Field$ = Field$ + x$ IF INSTR(Field$, ".") THEN NewMax = Max + 1 ELSE NewMax = Max END IF Field$ = MID$(Field$, 1, NewMax) END IF ' handle Bkspace IF ASC(x$) = 8 AND LEN(Field$) THEN Field$ = MID$(Field$, 1, LEN(Field$) - 1) END IF Signif$ = Field$ + "X" WHILE INSTR(" 0", MID$(Signif$, 1, 1)) Signif$ = MID$(Signif$, 2) WEND IF INSTR(Signif$, ".") THEN SignifLen = LEN(Signif$) - 2 ELSE SignifLen = LEN(Signif$) - 1 END IF ' handle Enter IF ASC(x$) = 13 AND SignifLen >= Min THEN oldLen = LEN(Field$) + 1 brake = 0 END IF ' handle Esc IF ASC(x$) = 27 THEN LOCATE atRow, atCol PRINT CHR$(219); SPACE$(Max); Field$ = "" IF INSTR(Rules$, "E") THEN EXIT SUB END IF END IF ' reprint if change, or beep if no change IF oldLen = LEN(Field$) THEN BEEP ELSE LOCATE atRow, atCol IF INSTR(Rules$, "P") THEN PRINT STRING$(LEN(Field$), 254); CHR$(219); " "; ELSE PRINT Field$; CHR$(219); " "; END IF END IF ' check for auto-Enter IF INSTR(Rules$, "A") THEN IF SignifLen = Max THEN brake = 0 END IF END IF WEND ' justify if required IF INSTR(Rules$, "J") THEN WHILE MID$(Field$, 1, 1) = "0" Field$ = MID$(Field$, 2) WEND Field$ = RIGHT$(SPACE$(NewMax) + Field$, NewMax) END IF ' reprint, deleting the cursor LOCATE atRow, atCol IF INSTR(Rules$, "P") THEN PRINT STRING$(LEN(Field$), 254); " "; ELSE PRINT Field$; " "; END IF CALL ziSetMCursorVis(11) END SUB ' '++++++++++++++++++++++++ SUB ziSetMCursorVis (Status) STATIC IF Mouse THEN SELECT CASE Status CASE 0 IF MCursorVis THEN Regs.AX = 2 CALL zzBasicInt(&H33) END IF CASE 1 Regs.AX = 1 CALL zzBasicInt(&H33) CASE 10 Regs.AX = &H2A CALL zzBasicInt(&H33) IF Regs.AX = 0 THEN TempFlag = 1 Regs.AX = 2 CALL zzBasicInt(&H33) ELSE TempFlag = 0 END IF CASE 11 IF TempFlag THEN Regs.AX = 1 CALL zzBasicInt(&H33) END IF END SELECT Regs.AX = &H2A CALL zzBasicInt(&H33) IF Regs.AX = 0 THEN MCursorVis = 1 ELSE MCursorVis = 0 END IF END IF END SUB ' '++++++++++++++++++++++++ SUB ziWander (Timeout!) IF Timeout! = 0 THEN WatchFor! = TIMER + 3600 ELSE WatchFor! = TIMER + Timeout! END IF Response = 0 DO x$ = INKEY$ IF LEN(x$) THEN SELECT CASE LEN(x$) CASE 1 A = INSTR(Allowed$, x$) IF A THEN Response = A EXIT DO END IF SELECT CASE ASC(x$) CASE 8: Response = 261 CASE 9: Response = 266 CASE 10: Response = 512 CASE 13: Response = 256 CASE 27: Response = 267 CASE 127: Response = 517 END SELECT IF Response THEN EXIT DO END IF CASE 2 Rightmost = ASC(RIGHT$(x$, 1)) SELECT CASE Rightmost CASE 15: Response = 1019 CASE 59 TO 68 Response = 4038 CASE 72: Response = 187 CASE 71 TO 73 Response = 191 CASE 75: Response = 182 CASE 77: Response = 181 CASE 80: Response = 180 CASE 79 TO 81 Response = 184 CASE 84 TO 93 Response = 16301 CASE 94 TO 103 Response = 8099 CASE 115 TO 116 Response = 398 CASE 117: Response = 402 CASE 118: Response = 403 CASE 119: Response = 399 CASE 127: Response = 390 CASE 132: Response = 388 CASE 133 TO 134 Response = 3974 CASE 135 TO 136 Response = 16260 CASE 137 TO 138 Response = 8066 END SELECT IF Response THEN Response = Response + Rightmost EXIT DO END IF END SELECT END IF IF Mouse AND MCursorVis THEN Regs.AX = 3 CALL zzBasicInt(&H33) SELECT CASE Regs.BX CASE 1 TO 3 Response = 2048 + Regs.BX nowtime! = TIMER DO Regs.AX = 3 CALL zzBasicInt(&H33) IF Regs.BX = 0 THEN EXIT DO LOOP UNTIL TIMER - nowtime! > .3 IF Regs.BX = Response - 2048 THEN Response = Response + 3 ELSE IF Regs.BX = 0 AND Response = 2049 AND DClick THEN nowtime! = TIMER DO Regs.AX = 3 CALL zzBasicInt(&H33) IF Regs.BX = 1 THEN EXIT DO LOOP UNTIL TIMER - nowtime! > .3 IF Regs.BX = 1 THEN Response = 2048 CALL ziExhaust END IF END IF IF Regs.BX = 3 THEN Response = 2051 END IF END IF END SELECT IF Response THEN MXloc = Regs.CX MYloc = Regs.DX EXIT DO END IF END IF LOOP UNTIL WatchFor! < TIMER HResponse = Response \ 256 LResponse = Response MOD 256 END SUB ' '++++++++++++++++++++++++ SUB zsAlignGCursor row = CSRLIN col = POS(0) GXloc = (col - 1) * ((Xmax + 1) \ Cols) GYloc = (row - 1) * ((((Ymax + 1) \ Rows) * Rows + 1) \ Rows) CALL zsLocateGCursor(GXloc, GYloc) END SUB ' '++++++++++++++++++++++++ SUB zsAlignTCursor GXloc = POINT(0) GYloc = POINT(1) A = (Xmax + 1) / Cols B = (Ymax + 1) / Rows col = (GXloc + A - 1) \ A + 1 row = (GYloc + B - 1) \ B + 1 LOCATE row, col CALL zsAlignGCursor END SUB ' '++++++++++++++++++++++++ SUB zsLocateGCursor (XCoord, YCoord) GXloc = XCoord GYloc = YCoord PSET (GXloc, GYloc), POINT(GXloc, GYloc) END SUB ' '++++++++++++++++++++++++ SUB zsPastel (XCoord, YCoord, Wide, Deep, colour1, colour2) CALL ziSetMCursorVis(10) IF Deep < 2 THEN A = Wide / XYratio! ELSE A = Deep END IF LINE (XCoord, YCoord)-(XCoord + Wide - 1, YCoord + A - 1), colour1, BF FOR B = XCoord TO XCoord + Wide - 1 STEP 2 LINE (B, YCoord)-(B, YCoord + A - 1), colour2, , &H5555 NEXT FOR B = XCoord + 1 TO XCoord + Wide - 1 STEP 2 LINE (B, YCoord)-(B, YCoord + A - 1), colour2, , &HAAAA NEXT CALL ziSetMCursorVis(11) END SUB ' '++++++++++++++++++++++++ SUB zsSetScrnMode (Mode, HiRows, HiCols) CALL ziSetMCursorVis(10) ScrnMode = Mode SELECT CASE Mode CASE 9 SCREEN 9 IF HiRows THEN Rows = 43 ELSE Rows = 25 END IF Xmax = 639 Ymax = 349 CASE 12 SCREEN 12 IF HiRows THEN Rows = 60 ELSE Rows = 30 END IF Xmax = 639 Ymax = 479 CASE 13 SCREEN 13 Rows = 25 Cols = 40 Xmax = 319 Ymax = 199 CASE ELSE RETURN END SELECT IF Mode <> 13 THEN IF HiCols THEN Cols = 80 ELSE Cols = 40 END IF END IF WIDTH Cols, Rows CLS SELECT CASE Mode CASE 9 COLOR fg, 0 CASE ELSE COLOR fg END SELECT LINE (0, 0)-(Xmax, Ymax), bg, BF LOCATE 1, 1, 0 PSET (0, 0), bg XYratio! = .75 * (Xmax + 1) / (Ymax + 1) CALL ziSetMCursorVis(11) END SUB ' '++++++++++++++++++++++++ SUB zsSubstitute (XCoord, YCoord, Wide, Deep, colour1, colour2) CALL ziSetMCursorVis(10) IF Deep < 2 THEN A = Wide / XYratio! ELSE A = Deep END IF FOR B = XCoord TO XCoord + Wide - 1 FOR C = YCoord TO YCoord + A - 1 IF POINT(B, C) = colour1 THEN PSET (B, C), colour2 END IF NEXT NEXT CALL ziSetMCursorVis(11) END SUB ' '++++++++++++++++++++++++ SUB zzAlphaSort (SortData$()) DIM SortPointers(SortCount, 2) FOR i = 2 TO SortCount j = 1 DO k = j IF SortData$(i) < SortData$(j) THEN j = SortPointers(j, 1) ELSE j = SortPointers(j, 2) END IF LOOP WHILE j <> 0 IF SortData$(i) < SortData$(k) THEN SortPointers(k, 1) = i ELSE SortPointers(k, 2) = i END IF NEXT SortPointers(0, 1) = 1 FOR i = 1 TO SortCount j = 0 DO WHILE SortPointers(j, 1) <> 0 k = j j = SortPointers(j, 1) LOOP SortPointers(k, 1) = SortPointers(j, 2) SWAP SortData$(i), SortData$(j) SWAP SortPointers(i, 1), SortPointers(j, 1) SWAP SortPointers(i, 2), SortPointers(j, 2) FOR k = 0 TO SortCount FOR l = 1 TO 2 IF SortPointers(k, l) = i THEN SortPointers(k, l) = j NEXT NEXT NEXT END SUB ' '++++++++++++++++++++++++ SUB zzBasicInt (IntType) STATIC DIM ASM(54) DEF SEG = VARSEG(ASM(0)) IF ASM(1) = 0 THEN Module$ = "BASICINT.OVL" CALL zzInPath(Module$) IF Module$ = "" THEN Module$ = "BASICINT.OVL" ERROR 255 ELSE BLOAD Module$, VARPTR(ASM(0)) END IF END IF CALL ABSOLUTE(Regs, IntType, VARPTR(ASM(0))) DEF SEG END SUB ' '++++++++++++++++++++++++ SUB zzChangeDir (Directory$) DIM str AS STRING * 65 str = LTRIM$(RTRIM$(UCASE$(Directory$))) + CHR$(0) IF MID$(str, 2, 1) = ":" THEN curdrive$ = MID$(str, 1, 1) str = MID$(str, 3) ELSE Regs.AX = &H1900 CALL zzBasicInt(&H21) curdrive$ = CHR$(65 + (Regs.AX AND 255)) END IF IF MID$(str, 1, 1) = CHR$(0) THEN GOSUB zzChangeDirAA EXIT SUB END IF str = curdrive$ + ":" + str Regs.AX = &H3B00 Regs.DS = VARSEG(str) Regs.DX = VARPTR(str) CALL zzBasicInt(&H21) IF (Regs.FL AND 256) = 256 THEN Directory$ = "" ELSE GOSUB zzChangeDirAA END IF EXIT SUB zzChangeDirAA: Regs.AX = &H4700 Regs.DX = ASC(curdrive$) - 64 Regs.DS = VARSEG(str) Regs.SI = VARPTR(str) CALL zzBasicInt(&H21) i = INSTR(str, CHR$(0)) Directory$ = curdrive$ + ":\" + MID$(str, 1, i - 1) RETURN END SUB ' '++++++++++++++++++++++++ SUB zzChangeDrive (Drive$) CALL zzCritOff GOSUB zzChangeDriveProcess CALL zzCritOn EXIT SUB zzChangeDriveProcess: Drive$ = LTRIM$(RTRIM$(UCASE$(Drive$))) IF LEN(Drive$) = 0 THEN Regs.AX = &H1900 CALL zzBasicInt(&H21) Drive$ = CHR$(65 + (Regs.AX AND 255)) + ":" RETURN END IF IF LEN(Drive$) = 1 THEN Drive$ = Drive$ + ":" IF LEN(Drive$) > 2 THEN Drive$ = "?" IF MID$(Drive$, 2, 1) = ":" THEN drv = ASC(Drive$) Drive$ = "?" IF drv < 65 THEN RETURN IF drv > 90 THEN RETURN drv = drv - 65 ' establish whether this is a shared drive Regs.AX = &H440E Regs.BX = drv + 1 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) = 256 THEN Regs.AX = 0 END IF Regs.AX = Regs.AX AND 255 IF Regs.AX <> 0 THEN IF Regs.AX <> drv + 1 THEN drv = Regs.AX - 1 END IF END IF ' establish whether this is a valid drive Regs.AX = &H1C00 Regs.DX = drv + 1 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN ' now change to it Regs.AX = &HE00 Regs.DX = drv CALL zzBasicInt(&H21) Drive$ = CHR$(65 + drv) + ":" ELSE Drive$ = "?" END IF RETURN END SUB SUB zzCritOff Regs.AX = &H2524 Regs.DS = VARSEG(IRET) Regs.DX = VARPTR(IRET) CALL zzBasicInt(&H21) CritCount = CritCount + 1 END SUB SUB zzCritOn CritCount = CritCount - 1 IF CritCount = 0 THEN Regs.AX = &H2524 Regs.DS = CritSeg Regs.DX = CritPtr CALL zzBasicInt(&H21) END IF END SUB ' '++++++++++++++++++++++++ SUB zzFileSelectBox (Pattern$) DIM Devices(26) ';valid devices have a non-zero value DIM validDevs(27) DIM parts$(11) ';ten deep is allowed DIM Dirs$(200) ';lots of subdirectories DIM Files$(200) ';lots of files DIM str AS STRING * 65 CALL zzCritOff GOSUB zzFileSelectBoxProcess CALL zzCritOn EXIT SUB zzFileSelectBoxProcess: ' create the screen IF screendone = 0 THEN bg = 7: fg = 15 CALL zsSetScrnMode(9, 1, 1) fg = 0 CALL ziPublishHere(3, 34, "Select a File", 1, 3) Stuff$ = "(Please Wait)" fg = 14 GOSUB zzFileSelectBoxDD ' print the headers fg = 8 CALL ziPublishHere(42, 17, "Use left & right arrow keys to change columns", 0, 1) END IF screendone = 1 fg = 8: CALL ziPublishHere(8, 2, "Drives", 2, 1): fg = 0 LINE (10, 7)-(Xmax - 10, Ymax - 7), 4, B IF NoDriveSelection = 0 THEN dev = 0: GOSUB zzFileSelectBoxAA ' find the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTAseg = Regs.ES DTAptr = Regs.BX ' establish the existing devices MaxDevs = 0 FOR i = 1 TO 26 Devices(i) = 0 validDevs(i) = 0 Regs.AX = &H440E Regs.BX = i CALL zzBasicInt(&H21) IF (Regs.FL AND 256) = 256 THEN Regs.AX = 0 END IF Regs.AX = Regs.AX AND 255 IF (Regs.AX = 0) OR (Regs.AX = i) THEN Regs.AX = &H1C00 Regs.DX = i CALL zzBasicInt(&H21) IF (Regs.AX AND 255) <> 255 THEN MaxDevs = MaxDevs + 1 Devices(i) = MaxDevs '; set the crossreference validDevs(MaxDevs) = i END IF END IF NEXT ' print the valid drives as a list fg = 0 FOR i = 1 TO MaxDevs x$ = CHR$(64 + validDevs(i)) + ":" CALL ziPublishHere(10 + i + i, 7, x$, 1, 0) NEXT END IF LINE (GXloc - 16, GYloc + 8)-(GXloc, 319), 7, BF 'clear rest of list NoDriveSelection = 0 fg = 8: CALL ziPublishHere(8, 20, "Tree", 2, 1): fg = 0 LINE (10, 7)-(Xmax - 10, Ymax - 7), 4, B ' carve off any 'wildcard' from the specified input parameter Pattern$ = UCASE$(LTRIM$(RTRIM$(Pattern$))) str = Pattern$ IF INSTR(str, "?") + INSTR(str, "*") = 0 THEN base$ = Pattern$ wild$ = "*.*" ELSE IF MID$(str, 2, 1) = ":" THEN start = 3 ELSE start = 1 END IF DO i = INSTR(start, str, "\") IF i <> 0 THEN start = i + 1 END IF LOOP UNTIL i = 0 base$ = MID$(str, 1, start - 1) wild$ = MID$(RTRIM$(str), start) END IF CALL zzValidate(base$) IF base$ = "?" THEN base$ = "" CALL zzChangeDir(base$) END IF IF MID$(base$, LEN(base$)) = "\" THEN basex$ = MID$(base$, 1, LEN(base$) - 1) ELSE basex$ = base$ END IF ' validate the "wildcard" portion ' (make sure no more than one ".") i = INSTR(wild$, ".") IF i <> 0 THEN x$ = wild$ MID$(x$, i, 1) = "+" IF INSTR(x$, ".") THEN wild$ = "*.*" i = 2 END IF END IF ' (divide it into its two component parts) IF i < 2 THEN wildl$ = wild$ wildr$ = "" ELSE wildl$ = MID$(wild$, 1, i - 1) wildr$ = MID$(wild$, i + 1) END IF IF LEN(wildl$) > 8 OR LEN(wildr$) > 3 THEN wild$ = "*.*" wildl$ = "*" wildr$ = "*" END IF ' (make sure no more than one TRAILING "*" in left part) i = INSTR(wildl$, "*") IF i <> 0 THEN IF i <> LEN(wildl$) THEN wild$ = "*.*" wildl$ = "*" wildr$ = "*" END IF END IF ' (make sure no more than one TRAILING "*" in right part) i = INSTR(wildr$, "*") IF i <> 0 THEN IF i <> LEN(wildr$) THEN wild$ = "*.*" wildl$ = "*" wildr$ = "*" END IF END IF i = 39 - LEN(wild$) \ 2 x$ = "[" + wild$ + "]" CALL ziPublishHere(7, i, x$, 0, 0) ' determine the specified drive dev = Devices(ASC(base$) - 64) GOSUB zzFileSelectBoxAA ' create the tree FOR i = 0 TO 11 parts$(i) = "" NEXT x$ = basex$ + "\" levels = 0 DO i = INSTR(x$, "\") IF i <> 0 THEN parts$(levels) = MID$(x$, 1, i - 1) levels = levels + 1 x$ = MID$(x$, i + 1) END IF LOOP UNTIL i = 0 parts$(0) = parts$(0) + "\" levels = levels - 1 CALL ziPublishHere(12, 15, parts$(0), 0, 0) IF levels > 0 THEN FOR i = 1 TO levels x$ = SPACE$(i + i) + CHR$(179) CALL ziPublishHere(11 + i + i, 13, x$, 0, 0) x$ = SPACE$(i + i) + CHR$(192) + CHR$(196) + parts$(i) CALL ziPublishHere(12 + i + i, 13, x$, 0, 0) NEXT END IF oldtree = 255 tree = levels GOSUB zzFileSelectBoxHH ' test for subdirectories present olddline = 0 x$ = basex$ + "\*.*" CALL zzSearchD(x$) IF Directories <> 0 THEN fg = 8: CALL ziPublishHere(8, 64, "Subdirs", 2, 1): fg = 0 FromDir = 1 GOSUB zzFileSelectBoxEE END IF ' test for files present x$ = basex$ + "\" + wild$ CALL zzSearchF(x$) IF FileNames <> 0 THEN fg = 8: CALL ziPublishHere(8, 51, "Files", 2, 1): fg = 0 FromFile = 1 GOSUB zzFileSelectBoxFF END IF ' determine where to start IF FileNames = 0 THEN IF Directories = 0 THEN fg = 4: CALL ziPublishHere(8, 20, "Tree", 2, 1): fg = 0 Stuff$ = basex$ + "\" GOSUB zzFileSelectBoxDD Column = 2 ELSE fg = 4: CALL ziPublishHere(8, 64, "Subdirs", 2, 1): fg = 0 dline = 1 GOSUB zzFileSelectBoxBB Stuff$ = basex$ + "\" + Directories$(FromDir) GOSUB zzFileSelectBoxDD Column = 4 END IF ELSE fg = 4: CALL ziPublishHere(8, 51, "Files", 2, 1): fg = 0 fline = 1 GOSUB zzFileSelectBoxCC Column = 3 END IF ' determine what to do, based on keystroke DO stroke$ = "X" DO stroke$ = INKEY$ LOOP UNTIL LEN(stroke$) = 0 DO stroke$ = INKEY$ LOOP WHILE LEN(stroke$) = 0 IF LEN(stroke$) = 1 THEN stroke$ = UCASE$(stroke$) SELECT CASE ASC(stroke$) CASE 27 'ESC Pattern$ = "?" RETURN CASE 13 'Enter SELECT CASE Column CASE 1 'enactivate new drive x$ = CHR$(validDevs(dev) + 64) + ":" Pattern$ = x$ + "\" + wild$ LINE (112, 88)-(383, 319), 7, BF 'clear the "tree" area GOSUB zzFileSelectBoxII GOTO zzFileSelectBoxProcess CASE 2 'choose new directory IF tree <> levels THEN base$ = "" FOR i = 0 TO tree base$ = base$ + parts$(i) IF MID$(base$, LEN(base$)) <> "\" THEN base$ = base$ + "\" END IF NEXT IF MID$(base$, LEN(base$)) <> "\" THEN base$ = base$ + "\" END IF Pattern$ = base$ + wild$ NoDriveSelection = 1 GOSUB zzFileSelectBoxII GOTO zzFileSelectBoxProcess END IF CASE 3 'exit with chosen filename Pattern$ = Stuff$ RETURN CASE 4 'choose new subdirectory Pattern$ = basex$ + "\" + Directories$(FromDir + dline - 1) Pattern$ = Pattern$ + "\" + wild$ NoDriveSelection = 1 GOSUB zzFileSelectBoxII GOTO zzFileSelectBoxProcess END SELECT CASE ASC("A") TO ASC("Z") SELECT CASE Column CASE 1 i = ASC(stroke$) - 64 IF Devices(i) <> 0 THEN dev = Devices(i) GOSUB zzFileSelectBoxAA END IF CASE 3 i = FileNames x$ = MID$(FileNames$(i), 1, 1) IF x$ >= stroke$ THEN i = 0 DO i = i + 1 x$ = MID$(FileNames$(i), 1, 1) LOOP WHILE x$ < stroke$ END IF FromFile = i GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 i = Directories x$ = MID$(Directories$(i), 1, 1) IF x$ >= stroke$ THEN i = 0 DO i = i + 1 x$ = MID$(Directories$(i), 1, 1) LOOP WHILE x$ < stroke$ END IF FromDir = i GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END SELECT END SELECT ELSE SELECT CASE MID$(stroke$, 2) CASE "I" 'Page UP SELECT CASE Column CASE 3 OldFromFile = FromFile IF FromFile + fline > 31 THEN FromFile = FromFile + fline - 31 ELSE FromFile = 1 END IF IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 OldFromDir = FromDir IF FromDir + dline > 31 THEN FromDir = FromDir + dline - 31 ELSE FromDir = 1 END IF IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END SELECT CASE "Q" 'Page DN SELECT CASE Column CASE 3 OldFromFile = FromFile IF FromFile + fline + 30 < FileNames THEN FromFile = FromFile + fline + 29 IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC END IF CASE 4 OldFromDir = FromDir IF FromDir + dline + 30 < Directories THEN FromDir = FromDir + dline + 29 IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END IF END SELECT CASE "G" 'HOME SELECT CASE Column CASE 3 IF FromFile <> 1 THEN FromFile = 1 GOSUB zzFileSelectBoxFF END IF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 IF FromDir <> 1 THEN FromDir = 1 GOSUB zzFileSelectBoxEE END IF dline = 1: GOSUB zzFileSelectBoxBB END SELECT CASE "O" 'END SELECT CASE Column CASE 3 OldFromFile = FromFile FromFile = FileNames - 29 IF FromFile < 1 THEN FromFile = 1 END IF IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 OldFromDir = FromDir FromDir = Directories - 29 IF FromDir < 1 THEN FromDir = 1 END IF IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END SELECT CASE "H" 'UP SELECT CASE Column CASE 1 'drives IF dev > 1 THEN dev = dev - 1 GOSUB zzFileSelectBoxAA END IF CASE 2 'tree IF tree > 0 THEN tree = tree - 1 GOSUB zzFileSelectBoxHH END IF CASE 3 'files i = FromFile + fline - 2 IF i > 0 THEN IF fline > 1 THEN fline = fline - 1 GOSUB zzFileSelectBoxCC ELSE OldFromFile = FromFile FromFile = FromFile - 30 fline = fline + 29 IF FromFile < 1 THEN fline = fline + FromFile - 1 FromFile = 1 END IF IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF GOSUB zzFileSelectBoxCC END IF END IF CASE 4 'subdirs i = FromDir + dline - 2 IF i > 0 THEN IF dline > 1 THEN dline = dline - 1 GOSUB zzFileSelectBoxBB ELSE OldFromDir = FromDir FromDir = FromDir - 30 dline = dline + 29 IF FromDir < 1 THEN dline = dline + FromDir - 1 FromDir = 1 END IF IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE GOSUB zzFileSelectBoxBB END IF END IF END SELECT CASE "P" 'DOWN SELECT CASE Column CASE 1 'drives IF dev < MaxDevs THEN dev = dev + 1 GOSUB zzFileSelectBoxAA END IF CASE 2 'tree IF tree < levels THEN tree = tree + 1 GOSUB zzFileSelectBoxHH END IF CASE 3 'files i = FromFile + fline IF i <= FileNames THEN IF fline < 30 THEN fline = fline + 1 GOSUB zzFileSelectBoxCC ELSE FromFile = i: GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC END IF END IF CASE 4 'subdirs i = FromDir + dline IF i <= Directories THEN IF dline < 30 THEN dline = dline + 1 GOSUB zzFileSelectBoxBB ELSE FromDir = i: GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END IF END IF END SELECT CASE "K" 'LEFT SELECT CASE Column CASE 2 'from TREE to DRIVES tree = levels GOSUB zzFileSelectBoxHH fg = 8: CALL ziPublishHere(8, 20, "Tree", 2, 1) fg = 4: CALL ziPublishHere(8, 2, "Drives", 2, 1): fg = 0 LINE (10, 7)-(Xmax - 10, Ymax - 7), 4, B Column = 1 CASE 3 'from FILES to TREE fg = 8: CALL ziPublishHere(8, 51, "Files", 2, 1) fg = 4: CALL ziPublishHere(8, 20, "Tree", 2, 1): fg = 0 Column = 2 CASE 4 'from SUBDIRS to ? dline = 0: GOSUB zzFileSelectBoxBB fg = 8: CALL ziPublishHere(8, 64, "Subdirs", 2, 1): fg = 4 IF FileNames = 0 THEN CALL ziPublishHere(8, 20, "Tree", 2, 1) Column = 2 ELSE CALL ziPublishHere(8, 51, "Files", 2, 1) Column = 3 END IF fg = 0 END SELECT CASE "M" 'RIGHT SELECT CASE Column CASE 1 'from DRIVES to TREE dev = Devices(ASC(base$) - 64) GOSUB zzFileSelectBoxAA 'return to original drive fg = 8: CALL ziPublishHere(8, 2, "Drives", 2, 1) fg = 15: LINE (10, 7)-(Xmax - 10, Ymax - 7), 4, B fg = 4: CALL ziPublishHere(8, 20, "Tree", 2, 1): fg = 0 Column = 2 CASE 2 'from TREE to ? tree = levels GOSUB zzFileSelectBoxHH IF FileNames = 0 THEN IF Directories <> 0 THEN fg = 8: CALL ziPublishHere(8, 20, "Tree", 2, 1) fg = 4: CALL ziPublishHere(8, 64, "Subdirs", 2, 1): fg = 0 dline = 1: GOSUB zzFileSelectBoxBB Column = 4 END IF ELSE fg = 8: CALL ziPublishHere(8, 20, "Tree", 2, 1) fg = 4: CALL ziPublishHere(8, 51, "Files", 2, 1): fg = 0 Column = 3 END IF CASE 3 'from FILES to SUBDIRS (if possible) IF Directories <> 0 THEN fg = 8: CALL ziPublishHere(8, 51, "Files", 2, 1) fg = 4: CALL ziPublishHere(8, 64, "Subdirs", 2, 1): fg = 0 dline = 1: GOSUB zzFileSelectBoxBB Column = 4 END IF END SELECT END SELECT END IF LOOP ' ╔════════════════╗ ' ║ AA ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ change the cursor bar on "dev" │ ' │ │ ' │ input: dev output: olddev │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxAA: IF dev <> olddev THEN FromRow = 10 + olddev + olddev ToRow = FromRow FromCol = 5 ToCol = 10 swap1 = bg: swap2 = fg IF olddev > 0 THEN GOSUB zzFileSelectBoxGG END IF FromRow = 10 + dev + dev ToRow = FromRow olddev = dev IF olddev > 0 THEN GOSUB zzFileSelectBoxGG END IF END IF RETURN ' ╔════════════════╗ ' ║ BB ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ change the cursor bar on "dline" │ ' │ │ ' │ input: dline output: olddline │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxBB: IF dline <> olddline THEN FromRow = 10 + olddline ToRow = FromRow FromCol = 67 ToCol = 78 swap1 = bg: swap2 = fg IF olddline > 0 THEN GOSUB zzFileSelectBoxGG FromRow = 10 + dline ToRow = FromRow olddline = dline IF dline > 0 THEN GOSUB zzFileSelectBoxGG END IF RETURN ' ╔════════════════╗ ' ║ CC ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ change the cursor bar on "fline" │ ' │ │ ' │ input: fline output: oldfline │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxCC: IF fline <> oldfline THEN FromRow = 10 + oldfline ToRow = FromRow FromCol = 51 ToCol = 62 swap1 = bg: swap2 = fg IF oldfline > 0 THEN GOSUB zzFileSelectBoxGG END IF FromRow = 10 + fline ToRow = FromRow oldfline = fline GOSUB zzFileSelectBoxGG Stuff$ = basex$ + "\" + FileNames$(FromFile + fline - 1) GOSUB zzFileSelectBoxDD END IF RETURN ' ╔════════════════╗ ' ║ DD ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ Determine middle of line for publishing "Stuff$" │ ' │ │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxDD: LINE (38, 26)-(601, 46), 3, BF LINE (38, 26)-(601, 46), 8, B CALL ziPublishHere(5, 40 - LEN(Stuff$) \ 2, Stuff$, 1, 2) RETURN ' ╔════════════════╗ ' ║ EE ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ Show 30 subdirectories │ ' │ │ ' │ input: FromDir │ ' │ │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxEE: LINE (512, 80)-(Xmax - 11, 319), 7, BF IF FromDir > Directories THEN RETURN IF FromDir > 1 THEN fg = 4: CALL ziPublishHere(11, 65, CHR$(24), 0, 0): fg = 0 END IF IF FromDir + 30 <= Directories THEN fg = 4: CALL ziPublishHere(40, 65, CHR$(25), 0, 0): fg = 0 j = FromDir + 29 ELSE j = Directories END IF FOR i = FromDir TO j k = INSTR(Directories$(i), ".") IF k = 0 THEN x$ = Directories$(i) ELSE x$ = MID$(Directories$(i), 1, k - 1) + SPACE$(8) x$ = MID$(x$, 1, 9) + MID$(Directories$(i), k + 1) END IF CALL ziPublishHere(11 + i - FromDir, 67, x$, 0, 1) NEXT olddline = 0 RETURN ' ╔════════════════╗ ' ║ FF ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ Show 30 filenames │ ' │ │ ' │ input: FromFile │ ' │ │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxFF: LINE (384, 80)-(495, 319), 7, BF IF FromFile > FileNames THEN RETURN IF FromFile > 1 THEN fg = 4: CALL ziPublishHere(11, 49, CHR$(24), 0, 0): fg = 0 END IF IF FromFile + 30 <= FileNames THEN fg = 4: CALL ziPublishHere(40, 49, CHR$(25), 0, 0): fg = 0 j = FromFile + 29 ELSE j = FileNames END IF FOR i = FromFile TO j k = INSTR(FileNames$(i), ".") IF k = 0 THEN x$ = FileNames$(i) ELSE x$ = MID$(FileNames$(i), 1, k - 1) + SPACE$(8) x$ = MID$(x$, 1, 9) + MID$(FileNames$(i), k + 1) END IF CALL ziPublishHere(11 + i - FromFile, 51, x$, 0, 0) NEXT oldfline = 0 RETURN ' ╔════════════════╗ ' ║ GG ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ Swap the colours (swap1 and swap2) of a region │ ' │ │ ' │ input: FromCol, FromRow, ToCol, ToRow, swap1, swap2 │ ' │ │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxGG: fx = FromCol * 8 - 8 fy = FromRow * 8 - 8 tx = ToCol * 8 - 1 ty = ToRow * 8 - 1 FOR ix = fx TO tx FOR iy = fy TO ty SELECT CASE POINT(ix, iy) CASE swap1 PSET (ix, iy), swap2 CASE swap2 PSET (ix, iy), swap1 END SELECT NEXT NEXT RETURN ' ╔════════════════╗ ' ║ HH ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ change the cursor bar on "tree" │ ' │ │ ' │ input: tree output: oldtree │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxHH: IF tree <> oldtree THEN FromRow = 12 + oldtree + oldtree ToRow = FromRow FromCol = 15 + oldtree + oldtree ToCol = FromCol + 11 swap1 = bg: swap2 = fg IF oldtree <> 255 THEN GOSUB zzFileSelectBoxGG END IF FromRow = 12 + tree + tree ToRow = FromRow FromCol = 15 + tree + tree ToCol = FromCol + 11 oldtree = tree GOSUB zzFileSelectBoxGG END IF RETURN ' ╔════════════════╗ ' ║ II ╟─────────────────────────────────────────────┐ ' ╚╤═══════════════╝ │ ' │ clear screen areas when changing directory │ ' │ │ ' │ │ ' └─────────────────────────────────────────────────────────────┘ zzFileSelectBoxII: oldtree = 255 oldfline = 0 olddline = 0 LINE (112, 16 * tree + 80)-(383, 319), 7, BF LINE (384, 56)-(495, 319), 7, BF LINE (504, 56)-(Xmax - 11, 319), 7, BF Stuff$ = "(Please Wait)" fg = 14: GOSUB zzFileSelectBoxDD: fg = 0 RETURN END SUB ' '++++++++++++++++++++++++ SUB zzInPath (Field$) x$ = ".;" + ENVIRON$("PATH") IF RIGHT$(x$, 1) <> ";" THEN x$ = x$ + ";" i = 1 DO j = INSTR(i, x$, ";") IF j THEN y$ = UCASE$(MID$(x$, i, j - i)) i = j + 1 IF RIGHT$(y$, 1) <> "\" THEN y$ = y$ + "\" F$ = y$ + Field$ Bad = 0 OPEN "I", 1, F$ IF Bad = 0 THEN CLOSE 1 EXIT DO END IF F$ = "" END IF LOOP WHILE j Bad = 0 Field$ = F$ END SUB ' '++++++++++++++++++++++++ SUB zzSearchD (Pattern$) DIM str AS STRING * 65 CALL zzCritOff GOSUB zzSearchDProcess CALL zzCritOn EXIT SUB zzSearchDProcess: upperbound = UBOUND(Directories$) str = LTRIM$(RTRIM$(UCASE$(Pattern$))) Pattern$ = "?" ' clear the Directories$ array FOR i = 1 TO 500 Directories$(i) = "" NEXT Directories = 0 ' locate the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTAseg = Regs.ES DTAptr = Regs.BX ' confirm that the drive (if specified) is valid IF MID$(str, 2, 1) = ":" THEN i = ASC(str) IF i < 65 THEN RETURN IF i > 90 THEN RETURN Regs.AX = &H440E Regs.BX = i - 64 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) <> 256 THEN j = Regs.AX AND 255 IF (j <> 0) AND (j <> i - 64) THEN i = j + 64 END IF END IF Regs.AX = &H1C00 Regs.DX = i - 64 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN END IF x$ = RTRIM$(str) IF (x$ = "") OR (MID$(x$, 2) = ":") THEN x$ = x$ + "*.*" END IF IF (MID$(x$, LEN(x$)) = "\") THEN x$ = x$ + "*.*" END IF IF INSTR(x$, "*") + INSTR(x$, "?") = 0 THEN x$ = x$ + "\*.*" END IF ' initiate the search Pattern$ = x$ str = x$ + CHR$(0) Regs.AX = &H4E00 Regs.CX = &H10 Regs.DS = VARSEG(str) Regs.DX = VARPTR(str) CALL zzBasicInt(&H21) DO WHILE (Regs.FL AND 256) = 0 DEF SEG = DTAseg ' pull the name (letter by letter) from the DTA IF (PEEK(DTAptr + &H15) AND &H10) = &H10 THEN Name$ = "" i = &H1E DO j = PEEK(DTAptr + i) IF j <> 0 THEN Name$ = Name$ + CHR$(j) END IF i = i + 1 LOOP UNTIL j = 0 ' omit "." and ".." IF MID$(Name$, 1, 1) <> "." THEN Directories = Directories + 1 IF Directories > upperbound THEN RETURN Directories$(Directories) = Name$ END IF END IF ' keep going until all matches are found Regs.AX = &H4F00 CALL zzBasicInt(&H21) LOOP ' now find the first byte of the directory pattern itself IF MID$(str, 2, 1) = ":" THEN start = 3 ELSE start = 1 END IF DO i = INSTR(start, str, "\") IF i <> 0 THEN start = i + 1 END IF LOOP UNTIL i = 0 x$ = MID$(str, 1, start - 1) CALL zzValidate(x$) IF MID$(x$, LEN(x$)) <> "\" THEN x$ = x$ + "\" i = INSTR(str, CHR$(0)) Pattern$ = RTRIM$(x$ + MID$(str, start, i - start)) IF Directories <> 0 THEN SortCount = Directories CALL zzAlphaSort(Directories$()) END IF RETURN END SUB ' '++++++++++++++++++++++++ SUB zzSearchF (Pattern$) DIM str AS STRING * 65 CALL zzCritOff GOSUB zzSearchFProcess CALL zzCritOn EXIT SUB zzSearchFProcess: upperbound = UBOUND(FileNames$) str = LTRIM$(RTRIM$(UCASE$(Pattern$))) Pattern$ = "?" ' clear the FileNames$ array FOR i = 1 TO 500 FileNames$(i) = "" NEXT FileNames = 0 ' locate the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTAseg = Regs.ES DTAptr = Regs.BX ' confirm that the drive (if specified) is valid IF MID$(str, 2, 1) = ":" THEN i = ASC(str) IF i < 65 THEN RETURN IF i > 90 THEN RETURN Regs.AX = &H440E Regs.BX = i - 64 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) <> 256 THEN j = Regs.AX AND 255 IF (j <> 0) AND (j <> i - 64) THEN i = j + 64 END IF END IF Regs.AX = &H1C00 Regs.DX = i - 64 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN END IF x$ = RTRIM$(str) IF (x$ = "") OR (MID$(x$, 2) = ":") THEN x$ = x$ + "*.*" END IF IF (MID$(x$, LEN(x$)) = "\") THEN x$ = x$ + "*.*" END IF IF INSTR(x$, "*") + INSTR(x$, "?") = 0 THEN x$ = x$ + "\*.*" END IF ' initiate the search Pattern$ = x$ str = x$ + CHR$(0) Regs.AX = &H4E00 Regs.CX = &H27 Regs.DS = VARSEG(str) Regs.DX = VARPTR(str) CALL zzBasicInt(&H21) DO WHILE (Regs.FL AND 256) = 0 DEF SEG = DTAseg ' pull the name (letter by letter) from the DTA Name$ = "" i = &H1E DO j = PEEK(DTAptr + i) IF j <> 0 THEN Name$ = Name$ + CHR$(j) END IF i = i + 1 LOOP UNTIL j = 0 FileNames = FileNames + 1 IF FileNames > upperbound THEN RETURN FileNames$(FileNames) = Name$ Regs.AX = &H4F00 CALL zzBasicInt(&H21) LOOP ' now find the first byte of the file pattern itself IF MID$(str, 2, 1) = ":" THEN start = 3 ELSE start = 1 END IF DO i = INSTR(start, str, "\") IF i <> 0 THEN start = i + 1 END IF LOOP UNTIL i = 0 x$ = MID$(str, 1, start - 1) CALL zzValidate(x$) IF MID$(x$, LEN(x$)) <> "\" THEN x$ = x$ + "\" i = INSTR(str, CHR$(0)) Pattern$ = RTRIM$(x$ + MID$(str, start, i - start)) IF FileNames <> 0 THEN SortCount = FileNames CALL zzAlphaSort(FileNames$()) END IF RETURN END SUB ' '++++++++++++++++++++++++ SUB zzValidate (Directory$) DIM str AS STRING * 65 CALL zzCritOff GOSUB zzValidateProcess CALL zzCritOn EXIT SUB zzValidateProcess: Candpath$ = LTRIM$(RTRIM$(UCASE$(Directory$))) IF MID$(Candpath$, LEN(Candpath$)) = "\" THEN IF LEN(Candpath$) > 1 THEN IF MID$(Candpath$, 2) <> ":\" THEN Candpath$ = MID$(Candpath$, 1, LEN(Candpath$) - 1) END IF END IF END IF Directory$ = "?" ' check that any named drive is valid IF MID$(Candpath$, 2, 1) = ":" THEN i = ASC(MID$(Candpath$, 1, 1)) IF i < 65 THEN RETURN IF i > 90 THEN RETURN Regs.AX = &H440E Regs.BX = i - 64 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) <> 256 THEN j = Regs.AX AND 255 IF (j <> 0) AND (j <> i - 64) THEN i = j + 64 END IF END IF Regs.AX = &H1C00 Regs.DX = i - 64 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN END IF ' handle special case of root directory IF Candpath$ = "\" THEN Directory$ = "" CALL zzChangeDrive(Directory$) Directory$ = Directory$ + "\" RETURN END IF IF MID$(Candpath$, 2) = ":\" THEN Directory$ = Candpath$ RETURN END IF ' handle special case of NO directory IF Candpath$ = "" THEN CALL zzChangeDir(Candpath$) Directory$ = Candpath$ RETURN END IF IF MID$(Candpath$, 2) = ":" THEN Regs.AX = &H4700 Regs.DX = ASC(MID$(Candpath$, 1, 1)) - 64 Regs.DS = VARSEG(str) Regs.SI = VARPTR(str) CALL zzBasicInt(&H21) i = INSTR(str, CHR$(0)) Directory$ = Candpath$ + "\" + MID$(str, 1, i - 1) RETURN END IF str = Candpath$ + CHR$(0) IF INSTR(str, "*") + INSTR(str, "?") > 0 THEN RETURN ' initiate the search Regs.AX = &H4E00 Regs.CX = &H10 Regs.DS = VARSEG(str) Regs.DX = VARPTR(str) CALL zzBasicInt(&H21) ' abandon if not a valid directory IF (Regs.FL AND 256) <> 0 THEN RETURN ' locate the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTAseg = Regs.ES DTAptr = Regs.BX DEF SEG = DTAseg attr = PEEK(DTAptr + &H15) IF (attr AND &H10) = 0 THEN RETURN ' establish the status quo so that we can change back olddrv$ = "" CALL zzChangeDrive(olddrv$) IF MID$(str, 2, 1) = ":" THEN newdrv$ = MID$(str, 1, 2) ELSE newdrv$ = olddrv$ END IF CALL zzChangeDrive(newdrv$) 'change to new drive olddir$ = "" CALL zzChangeDir(olddir$) 'find the current directory on new drive CALL zzChangeDir(str) 'change to the desired directory CALL zzChangeDir(olddir$) 'change back to the current directory CALL zzChangeDrive(olddrv$) 'change back to old drive IF Root = 0 THEN Directory$ = RTRIM$(str) ELSE Directory$ = MID$(str, 1, 2) + "\" END IF RETURN END SUB